home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
The 640 MEG Shareware Studio 2
/
The 640 Meg Shareware Studio CD-ROM Volume II (Data Express)(1993).ISO
/
pascal
/
boost4.zip
/
DEMO4.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1988-10-23
|
15KB
|
520 lines
Program Demo4;
{--------------------------------------------}
{ Demo4 }
{ Demonstrates many Boosters 4.0 routines }
{ }
{ Note: unit BOSHARE is a subset of the }
{ Boosters 4.0 library. }
{ }
{ Requires file Demo4.Gen, which contains }
{ screens created with ScrGen16. }
{ }
{ Written by George F. Smith }
{ 609 Candlewick Lane }
{ Lilburn, GA 30247 }
{ (404) 923-6879 }
{ }
{--------------------------------------------}
uses crt, dos, BOSHARE;
Type
TimeValues = array[1..6] of byte;
HexValues = array[1..3] of word;
Const
Boxbg : array[1..4] of byte = ($1E,$4E,$6E,$5E);
days : array[0..6] of String =
('Sunday','Monday','Tuesday','Wednesday','Thursday','Friday',
'Saturday');
quit = #27;
start = #13;
npage = 4;
var
Page : array[1..npage] of HeapBuf;
hour,
min,
sec,
i, j, n,
x1, y1,
x2, y2,
ecode : integer;
size : longint;
c : char;
s : String;
tod : TimeValues;
HexTime : HexValues;
{ ---------------- }
{ End the demo }
{ ---------------- }
Procedure EndDemo;
begin
ClrScr;
halt;
end; { EndDemo }
{ ------------------- }
{ Wait for a keypress }
{ ------------------- }
Procedure Pause;
begin
Pdq('e',Center('Press any key to continue, ESC to quit', 80,' '),1, 25, 11 );
repeat until KeyPressed;
c := readkey;
if c = quit then
EndDemo
else if KeyPressed then begin
c := readkey;
if c = #0 then
c := readkey;
end;
end; { Pause }
{ -------------------------------------------- }
{ Get the system time and set up the big clock }
{ -------------------------------------------- }
Procedure GetTime ( var TimeArray : timevalues; var B16Time : HexValues );
begin
with regs do
begin
{ Get current system time from DOS }
ax := $2C00;
intr($21,regs);
{ Demilitarize time }
if ch < 1 then
ch := 12
else
if ch > 12 then
ch := ch - 12;
TimeArray[1] := ch div 10;
TimeArray[2] := ch mod 10;
TimeArray[3] := cl div 10;
TimeArray[4] := cl mod 10;
TimeArray[5] := dh div 10;
TimeArray[6] := dh mod 10;
B16Time[1] := ch;
B16Time[2] := cl;
B16Time[3] := dh;
end;
end { GetTime };
{ ----------------------------- }
{ make STR procedure a function }
{ ----------------------------- }
function Fstr ( num : longint; width : integer) : String;
var
s : string[80];
begin
str ( num:width, s );
fstr := s;
end; { fstr }
BEGIN { demo }
{--- Show opening screen }
ClrScr;
Box ( 20, 6, 60, 13, 1, 14 );
SetAtt ( 20, 6, 60, 13, 30 );
CtrScr ( 'e', 'Boosters 4.0 Shareware Demo',39,21,7,30);
CtrScr ( 'e', 'Snow removal is INACTIVE',39,21,9,30);
CtrScr ( 'e', 'Press <ENTER> to continue',39,21,11,30);
{--- Find 'INACTIVE' on the screen and make it blink }
FindStr ( 21, 9, 'INACTIVE', 0, ecode );
if ecode = 0 then
SetAtt ( WhereX, WhereY,WhereX+7, WhereY, 158 )
else
EndDemo;
{--- Wait for ENTER to start or another key to quit }
c := readkey;
if c <> Start then
EndDemo;
{--- reserve heap space for NPAGE pages }
Mark(HeapTop);
for i := 1 to npage do
New ( page[i] );
{--- load screens 1 through 3 from Demo4.Gen, }
{--- beginning on page 2 of the heap }
Fil2Heap ( 'Demo4.Gen',1,3,page[2],ecode );
if ecode <> 0 then begin
CtrScr ( 'e', 'Can''t find file ''Demo4.Gen''',80,1,1,30 );
halt;
end;
{--- pop screen 1 of Demo4.Gen to the video display }
RestoreScreen ( Page[2] );
pause;
{--- display some boxes with different colors }
ClrScr;
for i := 1 to 4 do
begin
x1 := 1 + (i-1) * 20;
y1 := 1;
x2 := x1 + 19;
y2 := 10;
Box ( x1, y1, x2, y2, 4, 14 );
PutStr (h,
Center('SetAtt',18,' '),x1+1,5,14);
SetAtt ( x1, y1, x2, y2, boxbg[i] );
end;
PutStr ( h,Center('Greetings from Boosters',80 ,' '),1,12 ,14);
PutStr ( h,Center(' Version 4.0 ',80,' '),1,13,14);
PutStr ( h,
Center(' Running under Turbo Pascal 4.0 as a unit ',80,'-'),
1,15,14);
pause;
{--- Move the boxes }
MoveBlk ( 1, 12, 80, 15, 1, 19 );
SaveScreen ( Page[1] );
HeapAtt ( Page[1], 1, 1, 80, 14, 0 );
Heap2scr ( Page[1], 1, 1, 80, 14, 1, 1 );
pause;
{--- Change video attributes of boxes }
for i := 1 to 4 do
begin
x1 := 1 + (i-1) * 20;
y1 := 1;
x2 := x1 + 19;
y2 := 10;
PutStr (h,
Center('ChgAtt',18,' '),x1+1,5,boxbg[i] );
ChgAtt ( x1, y1, x2, y2, 0, boxbg[i] );
end;
pause;
{--- Create a tree image }
ClrScr;
for i := 1 to 22 do
begin
x1 := 1 + (i-1) * 2;
PutStr ( h, Center(Copies('░',x1),80,' '),1, i, 14 );
end;
pause;
{--- Make tree go away by saving it to the heap & clearing screen }
SaveScreen ( Page[1] );
ClrScr;
pause;
{--- Bring tree back from the heap }
RestoreScreen ( Page[1] );
pause;
{--- remove a portion of the tree with Remblkr }
box ( 1, 10, 80, 14, 1, 30 );
Remblkr ( 2, 11, 79, 13, 30 );
PutStr ( h,'Remblkr',37,12,30);
pause;
{--- Do the same with RemBlk }
Remblk (1, 10, 80, 14 );
PutStr ( h,'Remblk',38,12,14);
pause;
{--- launch the tree }
ClrScr;
for i := 22 downto 2 do
begin
MblkHeap ( Page[1], 18, 2, 65, i, 18, 1 );
RestoreScreen ( Page[1] );
end;
Heap2Scr ( Page[1], 1, 2, 80, 2, 1, 1 );
pause;
{--- Set up an image using RIGHT & LEFT }
ClrScr;
for i := 1 to 22 do
begin
x1 := 1 + (i-1) * 2;
PutStr ( h,right(Copies('░',x1),80,' '),1 ,i, 14 );
PutStr ( h, left(Copies('░',x1),80-x1,' '),1 ,i, 14 );
end;
pdq ('e', '[ LEFT ]',1,8,112);
pdq ('e', '[ RIGHT ]',72,8,112);
pause;
{--- strip away the numbers, front and back }
s := '.......111111122222223333333$trip function333333322222221111111.......';
ClrScr;
ctrscr ( 'e',s, 80, 1, 1, 14 );
GetStr ( h, s, 1, 1, 80 );
n := lastPos('$',s,length(s) );
setatt ( n,1,n,1,112 ); { highlight the $ }
s := strip(s,' ');
s := strip(s,'.');
ctrscr( 'e', s, 80, 1, 2, 11 );
s := strip(s,'1');
ctrscr( 'e', s, 80, 1, 3, 11 );
s := strip(s,'2');
ctrscr( 'e', s, 80, 1, 4, 11 );
s := strip(s,'3');
ctrscr( 'e', s, 80, 1, 5, 11 );
s := copies(s[lastPos('$',s,length(s) )],80 );
putstr (h, s, 1, 7, Getatt( n, 1) );
ctrscr ('e', '[ CtrScr, LastPos, Strip ]', 80, 1, 9, 30 );
pause;
{--- Create some boxes using BOXHEAP, then fire them to the screen }
ClrScr;
SaveScreen ( Page[1] );
Randomize;
for i := 1 to 8 do
begin
x1 := 1 + (i-1)*10;
x2 := x1 + 9;
y1 := 1;
y2 := 10;
BoxHeap ( Page[1],x1,y1,x2,y2,1+random(4),14 );
y1 := 15;
y2 := 24;
BoxHeap ( Page[1],x1,y1,x2,y2,1+random(4),14 );
end;
RestoreScreen ( Page[1] );
pdq ( 'e',Center('* * * BoxHeap * * *',80,' '),1, 12, 30 );
pdq ( 'e',Center('Jan. 1, 1989 is a '+Dows(1,1,1989),80,' '),1,13,14);
n := dow(8,15,1981);
s := days[n];
pdq ( 'e',Center('Aug. 15, 1981 is a '+s,80,' '),1,14,14);
pause;
{--- Create more boxes, using boxheap and cblkheap }
ClrScr;
Scr2Heap ( page[1],1,1,80,25,1,1 );
for i := 0 to 7 do
putstr ( h, fstr(i,1)+copies('-',9), 1+i*10, 1, 14 );
boxheap ( page[1], 1, 2, 10, 6, 4, 14 );
for i := 1 to 7 do
cblkheap ( page[1], 1, 2, 10, 6, 11+(i-1)*10, 2 );
cblkheap ( page[1], 1, 2, 80, 6, 1, 8 );
cblkheap ( page[1], 1, 8, 80, 12, 1, 14 );
cblkheap ( page[1], 1, 14, 80, 18, 1, 20 );
heap2scr ( page[1], 1, 2, 80, 24, 1, 2 );
pause;
{--- Circumnavigate the screen using MoveBg on the lower left box }
Fillheap ( page[1], 1, 20, 10, 24, ' ', 14 );
box ( 1, 20, 10, 24, 4, 112 );
pdq ( 'e',' MOVEBG ', 2, 22, 14 );
delay(500);
for i := 1 to 70 do
movebg ( page[1], i, 20, i+9, 24, i+1, 20 );
for i := 20 downto 3 do
movebg ( page[1], 71, i, 80, i+4, 71, i-1 );
for i := 71 downto 2 do
movebg ( page[1], i, 2, i+9, 6, i-1, 2 );
for i := 2 to 19 do
movebg ( Page[1], 1, i, 10, i+4, 1, i+1 );
delay(500);
box ( 1, 20, 10, 24, 4, 14 );
pause;
{--- Circumnavigate the screen using MoveBlkr, sweeping its trail clean }
box ( 1, 20, 10, 24, 4, 112 );
pdq ( 'e','MOVEBLKR', 2, 22, 14 );
delay(500);
for i := 1 to 70 do
moveblkr ( i, 20, i+9, 24, i+1, 20, 30 );
for i := 20 downto 3 do
moveblkr ( 71, i, 80, i+4, 71, i-1, 30 );
for i := 71 downto 2 do
moveblkr ( i, 2, i+9, 6, i-1, 2, 30 );
for i := 2 to 19 do
moveblkr ( 1, i, 10, i+4, 1, i+1, 30 );
delay(500);
box ( 1, 20, 10, 24, 4, 14 );
pause;
{--- Clear the heap and write it to the display }
fillheap ( page[1], 1, 1, 80, 25, ' ', 14 );
heap2scr ( page[1], 1, 1, 80, 25, 1, 1 );
{--- Write a cross-hatch pattern on the screen }
s := copystr('█▄',40);
n := cntch(S,'█');
for i := 1 to 25 do
pdq ( 'e', s, 1, i, 7 );
putstr ( h, Center(' COPYSTR ',80,'░'),1,12,14);
pdq ( 'e', Center(' CNTCH('+fstr(n,2)+') ',80,'▒'),1,13,14 );
diffone ( 'e' );
write('>');
pause;
{--- Clear lower half of the screen }
heap2scr ( page[1], 1, 14, 80, 25, 1, 14 );
pause;
{--- Copy top half of screen to bottom half }
pdq ('e', Center(' COPYBLK ',80,'▒'), 1, 13, 14 );
copyblk ( 1, 1, 80, 11, 1, 14 );
pause;
{--- Show a big clock }
s := copies(#196,80);
clrscr;
for i := 1 to 4 do
begin
pdq ( 'e', s, 1, i, 14 );
pdq ('e', s, 1, i + 20, 14 );
end;
box ( 8,6,73,19,1,14 );
repeat
GetTime ( tod, HexTime );
for i := 1 to 2 do
begin
x1 := 1 +tod[i] * 8;
x2 := x1 + 7;
heap2scr ( page[3], x1, 1, x2, 8, 9+(i-1)*8, 9 );
end;
heap2scr ( page[3], 1, 9, 8, 16, 25, 9 );
for i := 3 to 4 do
begin
x1 := 1 +tod[i] * 8;
x2 := x1 + 7;
heap2scr ( page[3], x1, 1, x2, 8, 17+(i-1)*8, 9 );
end;
heap2scr ( page[3], 1, 9, 8, 16, 49, 9 );
for i := 5 to 6 do
begin
x1 := 1 +tod[i] * 8;
x2 := x1 + 7;
heap2scr ( page[3], x1, 1, x2, 8, 25+(i-1)*8, 9 );
end;
{--- Show time in hex }
ctrscr ( 'e', right(stripr(hex(hextime[1]),'l','0'),2,'0')+':'+
right(stripr(hex(hextime[2]),'l','0'),2,'0')+':'+
right(stripr(hex(hextime[3]),'l','0'),2,'0'),80,1,20,30 );
{--- Show time in binary }
s[0] := #18; { set length }
for i := 1 to 4 do
s[5-i] := chr(48 + hextime[1] shr (i-1) and 1);
s[5] := ':';
for i := 1 to 6 do
s[12-i] := chr(48 + hextime[2] shr (i-1) and 1);
s[12] := ':';
for i := 1 to 6 do
s[19-i] := chr(48 + hextime[3] shr (i-1) and 1);
ctrscr ( 'e', s, 80, 1, 5, 30 );
until keypressed;
if KeyPressed then begin
c := readkey;
if c = #0 then c := readkey;
end;
{--- Create random patterns on the screen and search for 'EE' }
Randomize;
ClrScr;
s[0] := #1;
for i := 1 to 25 do
for n := 1 to 80 do
begin
s[1] := chr(65+random(10));
pdq ('e',s,n,i,7);
end;
x1 := 1;
y1 := 1;
s := 'EE';
repeat
findstr ( x1,y1,s,0,ecode );
if ecode = 0 then
setatt ( wherex, wherey, wherex+length(s)-1, wherey, 30 );
x1 := wherex + 2;
y1 := wherey;
until (ecode > 0) or (y1 = 25);
ctrscr ( 'e', '< F I N D S T R >',80,1,12,14 );
pause;
{--- Report number of occurrences of 'EE' }
SaveScreen ( Page[1] );
ClrScr;
CtrScr ('e','<< F S T R H E A P >>',80,1,1,30 );
pdq ('e',S+' was found at the following coordinates:',1,2,14);
x1 := 1;
y1 := 1;
i := 3;
repeat
fstrheap ( Page[1], s, x1, y1, ecode );
if ecode = 0 then
begin
pdq ('e','('+fstr(x1,2)+','+fstr(y1,2)+')',10,i,14 );
getheap ( Page[1], h, s, x1, y1, length(s) );
pdq ('e', s + ' (fetched by Getheap)', 18, i, 14 );
end;
i := i + 1;
x1 := x1+length(s);
until ecode > 0;
pause;
{--- Propagate message on line 25 using GetAtt, GetChar }
repeat
for i := 25 downto 2 do
for j := 1 to 80 do
pdq ('e',getchar(j,i), j, i-1, getatt(j,i) );
for i := 25 downto 2 do
pdq ('e',copies(' ',80),1, i, getatt(j,i) );
for i := 1 to 24 do
for j := 1 to 80 do
pdq ('e',getchar(j,i), j, i+1, getatt(j,i) );
for i := 1 to 24 do
pdq ('e',copies(' ',80),1, i, getatt(j,i) );
until keypressed;
if KeyPressed then begin
c := readkey;
if c = #0 then c := readkey;
end;
{--- Tell user what we did }
ctrscr ('e','A little bounce using ', 80,1,11,30 );
ctrscr ('e',' GETCHAR & GETATT ',80,1,12,30 );
pause;
{--- Create a pattern using Rword }
ClrScr;
s := 'Rword Try Rword';
PutStr(h,Center(S,80,' '),1,1,14);
for i := 0 to 20 do
PutStr ( h,Center(Rword(S,2,Copies('-',1+i*2)),80,' '),1,i+2,14 );
pause;
{--- Using the Space function }
ClrScr;
s := 'Space Space';
for i := 10 downto 0 do
PutStr ( h,Center(Space(S,i+i*5,'░'),80,' '),1,11-i,14 );
for i := 1 to 10 do
PutStr ( h,Center(Space(S,i+i*5,'░'),80,' '),1,11+i,14 );
pause;
{--- Some elementary heap manipulation }
RestoreScreen ( Page[1] );
CtrScr ( 'e','Current Page 1 of Heap',80,1,1,112 );
pause;
CopyHeap ( Page[2],Page[1],1,1,80,25,1,1 );
RestoreScreen ( Page[1] );
CtrScr ( 'e','After Copying Page 2 to Page 1 using CopyHeap',80,1,1,112);
pause;
ClrScr;
Release ( HeapTop );
END. { Demo4 }